home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / env / assem.scm next >
Text File  |  1995-10-13  |  11KB  |  318 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3. ; Byte-code assembler (Richard's version)
  4.  
  5. ; (lap <spec> <insts>*)
  6. ; <spec> ::= <identifier> | (<identifier> <arg>*)
  7. ; <arg>  ::= <identifier>
  8. ; <inst> ::= (<op-code> . <operands>) |
  9. ;            <label> |
  10. ;            (global <identifier>) |
  11. ;            (set-global! <identifier>) |
  12. ;            (local <identifer>) |
  13. ;            (set-local! <identifier>) |
  14. ;            (literal <anything>) | (literal (quote <anything>)) |
  15. ;            (computed-goto <label>* <default-label>)  ; not yet implemented
  16. ; <operand> ::= <number> | <label> | <stob-name> |
  17. ;               (lap <spec> <insts>*) ; only where a template is expected
  18. ;              
  19. ; If any <arg>'s are specified, you have to do a MAKE-ENV to get LOCAL and
  20. ; SET-LOCAL! to work properly (the assembler assumes that you are using
  21. ; environments in the same way as the byte-code compiler).
  22. ;
  23. ; QUOTE is optional for literals, unless the value is itself quoted.
  24. ;
  25. ; The assembler uses opcode-arg-specs to check the number and type of arguments
  26. ; to the opcodes.
  27.  
  28. (define-compilator 'lap syntax-type
  29.   (lambda (node cenv depth cont)
  30.     (let* ((exp (node-form node))
  31.        (template (compile-lap (cadr exp) (cddr exp) cenv)))
  32.       (fixup-template-refs! template)
  33.       (deliver-value (instruction-with-literal op/closure template)
  34.              cont))))
  35.  
  36. (define template-marker (cons #f #f))
  37.  
  38. (define (make-template-marker name)
  39.   (cons template-marker name))
  40.  
  41. (define (template-marker? x)
  42.   (and (pair? x)
  43.        (eq? (car x) template-marker)))
  44.  
  45. (define template-marker-name cdr)
  46.  
  47. (define (fixup-template-refs! template)
  48.   (let ((templates '()))
  49.     (let label ((template template))
  50.       (if (symbol? (template-info template))
  51.       (set! templates (cons (cons (template-info template) template)
  52.                 templates)))
  53.       (do ((i 0 (+ i 1)))
  54.       ((>= i (template-length template)))
  55.     (if (template? (template-ref template i))
  56.         (label (template-ref template i)))))
  57.     (let label ((template template))
  58.       (do ((i 0 (+ i 1)))
  59.       ((>= i (template-length template)))
  60.     (let ((x (template-ref template i)))
  61.       (cond ((template? x)
  62.          (label x))
  63.         ((not (template-marker? x)))
  64.         ((assq (template-marker-name x) templates)
  65.          => (lambda (t)
  66.               (template-set! template i (cdr t))))
  67.         (else
  68.          (error "no template of this name available"
  69.             (template-marker-name x)))))))))
  70.  
  71. (define (compile-lap spec insts cenv)
  72.   (let ((id (if (pair? spec) (car spec) spec))
  73.     (cenv (if (pair? spec) (bind-vars (cdr spec) cenv) cenv)))
  74.     (segment->template (really-compile-lap insts cenv) id 0)))
  75.     
  76. ; Assemble each instruction, keeping track of which ones use labels.
  77. ; STUFF is a list of lists of the form (<inst> <offset> . <preceding-insts>)
  78. ; which indicates that <inst> uses a label, the it ends at <offset>, and is
  79. ; preceded by <preceding-insts>.
  80.  
  81. (define (really-compile-lap insts cenv)
  82.   (let loop ((insts insts) (segments '()) (stuff '()) (offset 0) (labels '()))
  83.     (cond ((null? insts)
  84.        (fixup-lap-labels segments stuff labels))
  85.       ((pair? (car insts))
  86.        (call-with-values
  87.         (lambda () (assemble-instruction (car insts) cenv))
  88.         (lambda (segment label-use?)
  89.           (let ((offset (+ offset (segment-size segment))))
  90.         (if label-use?
  91.             (loop (cdr insts)
  92.               '()
  93.               `((,(car insts) ,offset . ,segments) . ,stuff)
  94.               offset
  95.               labels)
  96.             (loop (cdr insts)
  97.               (cons segment segments)
  98.               stuff
  99.               offset
  100.               labels))))))
  101.       ((or (symbol? (car insts))
  102.            (integer? (car insts)))
  103.        (loop (cdr insts) segments stuff offset
  104.          (cons (cons (car insts) offset) labels)))
  105.       (else
  106.        (error "bad LAP instruction" (car insts))))))
  107.  
  108. ; Reassemble the instruction at the beginning of each STUFF list to resolve
  109. ; the label reference and glue everything together using SEQUENTIALLY.  The
  110. ; label code assumes that the machine calculates the label from the end of
  111. ; the instruction.
  112.  
  113. (define (fixup-lap-labels segments stuff labels)
  114.   (let loop ((stuff stuff) (segment (apply sequentially (reverse segments))))
  115.     (if (null? stuff)
  116.     segment
  117.     (let* ((data (car stuff))
  118.            (inst (car data))
  119.            (offset (cadr data))
  120.            (segments (cddr data)))
  121.       (loop (cdr stuff)
  122.         (sequentially (apply sequentially (reverse segments))
  123.                   (reassemble-instruction inst offset labels)
  124.                   segment))))))
  125.  
  126. ; This returns two values, the assembled instruction and a flag indicating
  127. ; whether or not the instruction used a label.
  128.  
  129. (define (assemble-instruction inst cenv)
  130.   (really-assemble-instruction inst cenv (lambda (label) (values 0 0))))
  131.  
  132. ; Same as the above, except that labels are resolved and no flag is returned.
  133.  
  134. (define (reassemble-instruction inst offset labels)
  135.   (call-with-values
  136.    (lambda ()
  137.      (really-assemble-instruction inst #f (resolve-label offset labels)))
  138.    (lambda (inst ignore)
  139.      inst)))
  140.  
  141. (define (resolve-label offset labels)
  142.   (lambda (label)
  143.     (cond ((assoc label labels)
  144.        => (lambda (p)
  145.         (let ((delta (- (cdr p) offset)))
  146.           (values (quotient delta byte-limit)
  147.               (remainder delta byte-limit)))))
  148.       (else
  149.        (error "LAP label is not defined" label)))))
  150.  
  151. (define (really-assemble-instruction inst cenv labels)
  152.   (let ((opname (car inst))
  153.     (args (cdr inst)))
  154.     (cond ((assemble-special-op opname args cenv)
  155.        => (lambda (inst)
  156.         (values inst #f)))
  157.       ((name->enumerand opname op)
  158.        => (lambda (opcode)
  159.         (assemble-general-instruction opcode inst cenv labels)))
  160.       (else
  161.        (error "unknown LAP instruction" inst)))))
  162.  
  163. ; The optional ' is optionally stripped off the argument to LITERAL.
  164.  
  165. (define (assemble-special-op opname args cenv)
  166.   (case opname
  167.     ((literal)
  168.      (let* ((arg (car args))
  169.         (arg (if (and (pair? arg)
  170.               (eq? (car arg) 'quote))
  171.              (cadr arg)
  172.              arg)))
  173.        (instruction-with-literal op/literal arg)))
  174.     ((global)
  175.      (lap-global #f (car args) cenv))
  176.     ((set-global!)
  177.      (lap-global #t (car args) cenv))
  178.     ((local)
  179.      (if (null? (cdr args))
  180.      (lap-local (car args) cenv)
  181.      #f))
  182.     ((set-local!)
  183.      (if (null? (cdr args))
  184.      (lap-set-local! (car args) cenv)
  185.      #f))
  186.     (else
  187.      #f)))
  188.  
  189. (define (lap-global assign? name cenv)
  190.   (let ((binding (lookup cenv name)))
  191.     (if (and (binding? binding) (not (location? (binding-place binding))))
  192.     (error "LAP variable is not global" name)
  193.     (instruction-with-location
  194.          (if assign? op/set-global! op/global)
  195.          (get-location binding
  196.                cenv
  197.                name
  198.                (if assign? usual-variable-type value-type))))))
  199.  
  200. (define (lap-local name cenv)
  201.   (let ((binding (lookup cenv name)))
  202.     (if (and (binding? binding)
  203.          (pair? (binding-place binding)))
  204.     (let* ((level+over (binding-place binding))
  205.            (back (- (environment-level cenv)
  206.             (car level+over)))
  207.            (over (cdr level+over)))
  208.       (case back
  209.         ((0) (instruction op/local0 over))
  210.         ((1) (instruction op/local1 over))
  211.         ((2) (instruction op/local2 over))
  212.         (else (instruction op/local back over))))
  213.     (error "LAP local variable is not locally bound" name))))
  214.       
  215. (define (lap-set-local! name cenv)
  216.   (let ((binding (lookup cenv name)))
  217.     (if (and (binding? binding)
  218.          (pair? (binding-place binding)))
  219.     (let* ((level+over (binding-place binding))
  220.            (back (- (environment-level cenv)
  221.             (car level+over)))
  222.            (over (cdr level+over)))
  223.       (instruction op/set-local! back over))
  224.     (error "LAP local variable is not locally bound" name))))
  225.  
  226. ; This returns two values, the assembled instruction and a flag indicating
  227. ; whether or not the instruction used a label.
  228.  
  229. (define (assemble-general-instruction opcode inst cenv labels)
  230.   (let ((specs (vector-ref opcode-arg-specs opcode))
  231.     (args (cdr inst))
  232.     (finish (lambda (ops label-use?)
  233.           (values (apply instruction opcode (reverse ops))
  234.               label-use?))))
  235.     (let loop ((specs specs) (args args) (ops '()) (label-use? #f))
  236.       (if (null? specs)
  237.       (finish ops label-use?)
  238.       (case (car specs)
  239.         ((index) ; segment.scm allows no other operands if an index is used.
  240.                      ; All non-template indexed operands should have been taken
  241.                      ; care of above (probably should fix arch.scm).
  242.          (let ((template (if (null? (cdr args))
  243.                  (make-template-marker (car args))
  244.                  (compile-lap (car args) (cdr args) cenv))))
  245.            (values (instruction-with-final-literal opcode
  246.                                (reverse ops)
  247.                                template)
  248.                label-use?)))
  249.         ((offset)
  250.          (let ((label (check-lap-arg args 'label inst)))
  251.            (call-with-values
  252.         (lambda () (labels label))
  253.         (lambda (high low)
  254.           (loop (cdr specs) (cdr args) `(,low ,high . ,ops) #t)))))
  255.         ((stob)
  256.          (let ((byte (check-lap-arg args 'stob inst)))
  257.            (loop (cdr specs) (cdr args) (cons byte ops) label-use?)))
  258.         ((nargs byte)
  259.          (let ((byte (check-lap-arg args 'byte inst)))
  260.            (loop (cdr specs) (cdr args) (cons byte ops) label-use?)))
  261.         (else
  262.          (if (or (eq? (car specs) '+)
  263.              (integer? (car specs)))
  264.          (finish ops label-use?)
  265.          (error "unknown opcode argument specification" (car specs)))))))))
  266.  
  267. ; Compiler doesn't provide this so we hack it up.
  268.  
  269. (define (instruction-with-final-literal opcode operands literal)
  270.   (cond ((null? operands)
  271.      (instruction-with-literal opcode literal))
  272.     (else
  273.      (sequentially (apply instruction
  274.                   opcode
  275.                   (reverse (cdr (reverse operands))))
  276.                (instruction-with-literal (car (reverse operands))
  277.                          literal)))))
  278.  
  279. ; Check that the car of ARGS is an argument of the appropriate type and
  280. ; return it.
  281.  
  282. (define (check-lap-arg args type inst)
  283.   (if (null? args)
  284.       (error "not enough arguments in LAP instruction" inst))
  285.   (let ((arg (car args)))
  286.     (case type
  287.       ((byte)
  288.        (if (integer? arg)
  289.        arg
  290.        (error "numeric operand expected in LAP instruction" inst)))
  291.       ((stob)
  292.        (cond ((name->enumerand arg stob)
  293.           => (lambda (x) x))
  294.          (else
  295.           (error "unknown STOB argument in LAP instruction" inst))))
  296.       ((label)
  297.        (cond ((symbol? arg)
  298.           arg)
  299.          ((and (pair? arg)
  300.            (eq? (car arg) '=>))
  301.           (cadr arg))
  302.          (else
  303.           (error "bad label in LAP instruction" inst))))
  304.       (else
  305.        (error "LAP internal error, unknown LAP argument specifier" type)))))
  306.         
  307. (define byte-limit (expt 2 bits-used-per-byte))
  308.  
  309. (define op/closure (enum op closure))
  310. (define op/global  (enum op global))
  311. (define op/literal (enum op literal))
  312. (define op/local   (enum op local))
  313. (define op/local0  (enum op local0))
  314. (define op/local1  (enum op local1))
  315. (define op/local2  (enum op local2))
  316. (define op/set-global! (enum op set-global!))
  317. (define op/set-local!  (enum op set-local!))
  318.